home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0920.ZIP / RFORM.ARC / _RFORM.IMP < prev    next >
Text File  |  1988-01-06  |  3KB  |  102 lines
  1. function Form(Picture : string;
  2.               R       : real) : string;
  3.  
  4.   const NumFieldSet : set of char = ['$','#','@','*','-','+',',','.'];
  5.  
  6.   var FieldStr,
  7.       TS       : string;
  8.       Position,
  9.       I,K,DP   : word;
  10.  
  11.   begin
  12.     Position:=1;     {Ignore stand alone '.' and ','}
  13.     while ((not (Picture[Position] in NumFieldSet)) and (Position <= length(Picture)))
  14.       or ((Picture[Position] in ['.',',']) and (not (Picture[Position+1] in NumFieldSet))) do
  15.         inc(Position);
  16.     if (Position > length(Picture)) then
  17.       begin
  18.         Position:=0;
  19.         FieldStr:='';
  20.       end
  21.     else
  22.       begin
  23.         I:=Position;
  24.         while (Picture[I] in NumFieldset)
  25.           and (I <= length(Picture)) do
  26.             inc(I);
  27.         FieldStr:= copy(Picture,Position,I-Position);
  28.       end;
  29.     TS:=FieldStr;
  30.     for I:=length(TS) downto 1 do
  31.       if (TS[I] in [',','+','-']) then
  32.         delete(TS,I,1);
  33.     I:=pos('.',TS);
  34.     if (I<>0) then                       {Calculate decimal places}
  35.       DP:=length(TS)-I
  36.     else
  37.       DP:=0;
  38.     str(R:0:DP,TS);
  39.     for I := length(TS) downto 1 do
  40.       if (TS[I] in ['+','-','.']) then       {remove sign from string}
  41.         delete(TS,I,1);
  42.     I:=length(TS);
  43.     for K:=length(FieldStr) downto 1 do
  44.       begin
  45.         if (I<>0) then
  46.           if (FieldStr[K] in [',','+','-','.']) then
  47.             insert('!',TS,I+1)
  48.           else
  49.             dec(I);
  50.       end;
  51.     if (pos('@',FieldStr)<>0) then
  52.       begin
  53.         while (length(TS) < length(FieldStr)-1) do
  54.           TS:='0'+TS;
  55.         if (R<0) then
  56.           TS:='-'+TS
  57.         else
  58.           if (length(TS) < length(FieldStr)) then
  59.             TS:='0'+TS;
  60.      end
  61.    else
  62.       begin
  63.         if (pos('$',FieldStr)<>0) then
  64.           TS := '$'+TS;
  65.         if (Pos('-',FieldStr)=0)
  66.           and (Pos('+',FieldStr)=0)
  67.           and (R<0) then
  68.             TS := '-'+TS;
  69.         if (pos('*',FieldStr)<>0) then
  70.           while (length(TS) < length(FieldStr)) do
  71.             TS:='*'+TS
  72.         else
  73.           while (length(TS) < length(FieldStr)) do
  74.             TS:=' '+TS;
  75.       end;
  76.     for K:=1 to length(FieldStr) do
  77.       case FieldStr[K] of
  78.         '+' : if (R<0) then
  79.                   TS[K]:='-'
  80.               else
  81.                 TS[K]:='+';
  82.         '-' : if (R<0) then
  83.                 TS[K]:='-'
  84.               else
  85.                 TS[K]:=' ';
  86.         ',' : if (TS[K] = '!') then
  87.                 TS[K]:=',';
  88.         '.' : if (TS[K] = '!') and (K=length(TS)) then
  89.                 TS[K]:=' '
  90.               else
  91.                 TS[K]:='.';
  92.       end;
  93.     if length(TS) > length(FieldStr) then
  94.       begin
  95.         fillchar(TS,sizeof(TS),'*');
  96.         TS[0]:=FieldStr[0];
  97.       end;
  98.     for I:=1 to length(TS) do
  99.       Picture[Position+I-1]:=TS[I];
  100.     Form:=Picture;
  101.   end;
  102.